home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Especial Multimedia
/
Especial Multimedia.iso
/
Multimed
/
Fuentes
/
FNTPREV.ZIP
/
PREVIEW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1997-09-14
|
30KB
|
956 lines
{Font Preview - 1.3 Program Copyright (C) Doug Overmyer 7/26/91}
program FList;
{$S-}
{$R PREVIEW.RES}
{$R-}
uses WinTypes, WinProcs, WinDos, Strings, WObjects,WOPlus,WFPlus,StdDlgs,
printer,pDevice;
const
id_OKPrt = 521; {OK button in Dlg3}
id_Ec1 = 506; {Edit control element in Dlg3}
id_But1 = 201; {User defined button 1}
id_But2 = 202; { " 2}
id_But3 = 203; { " 3}
id_But4 = 204; { " 3}
id_But5 = 205; { " 5}
id_Lb1 = 301; {List box control in Dlg1}
id_lb2 = 302; {id of FBox list box control}
id_Setup = 501; {Setup button in Dlg3}
id_St1 = 401; {Static text 1 }
id_St2 = 402; {Static text 2 }
id_St3 = 403; {Static text 3 }
id_St4 = 404; {Static text 4 }
idm_About = 801; {menu id for PV_About menu}
idm_RunCP = 802; {menu id for run control panel}
um_FilePrint = 802; {User defined message }
{******************************************************************}
{ Types }
{******************************************************************}
type
TPVApplication = object(TApplication)
procedure InitMainWindow;virtual;
end;
PPVDlg1 = ^TPVDlg1; {Font Sizes Dialog}
TPVDlg1 = object(TDialog)
FontSize: Integer;
procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
procedure IDLb1(var Msg:TMessage);virtual id_First+id_Lb1;
end;
PPVDlg2 = ^TPVDlg2; {String Dialog}
TPVDlg2 = object(TDialog)
DCType:Char;
procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
end;
PPVDlg3 = ^TPVDlg3;
TPVDlg3 = object(TDialog) {Print setup dialog}
PFontSize: Integer;
procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
procedure IDSetup(var Msg:TMessage);virtual id_First+id_Setup;
procedure IDOKPrt(var Msg:TMessage);virtual id_First+id_OKPrt;
procedure IDEc1(var Msg:TMessage);virtual id_First+id_Ec1;
end;
type {convert TLogFont records to objects}
PFontItem = ^TFontItem;
TFontItem = object(TObject)
LogFont:TLogFont;
FontType:Integer;
constructor Init(NewItem:TLogFont;NewType:Integer);
destructor Done;virtual;
end;
PFontCollection = ^TFontCollection; {Collection of printer TLOGFont recs}
TFontCollection = object(TSortedCollection)
function KeyOf(Item:Pointer):Pointer;virtual;
function Compare(Key1,Key2:Pointer):Integer;virtual;
function GetCount:Integer;virtual;
end;
type {Child win to display sample text}
PFontWindow = ^TFontWindow;
TFontWindow = object(TWindow)
FontsHeight: LongInt;
constructor Init(AParent: PWindowsObject; ATitle: PChar);
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
procedure Destroy; virtual;
procedure WMSize(var Msg: TMessage);
virtual wm_First + wm_Size;
end;
type {Printer object support for margins,fonts}
PPVPrinter = ^TPVPrinter;
TPVPrinter = object(tPrinter)
MarginL:Integer; {left horiz margin value in Pixels}
MarginT:Integer; {top vert margin value in Pixels}
MarginR:Integer; {right horiz margin value in Pixels}
MarginB:Integer; {bottom vert margin value in Pixels}
function Start(dName:pChar;hw:HWnd):Boolean;virtual;
procedure SetMarginL(NewMargin:Integer);virtual;
procedure SetMarginT(NewMargin:Integer);virtual;
procedure SetMarginR(NewMargin:Integer);virtual;
procedure SetMarginB(NewMargin:Integer);virtual;
function SetFont(NewFont:hFont):hFont;virtual;
function NewLine:Boolean; virtual;
function resetPos:Boolean;virtual;
function CheckNewPage:Boolean; virtual;
function Print(aStr:pChar):Boolean;virtual;
function prnDeviceMode(Wnd:HWnd):Integer;virtual;
end;
type {MainWindow of Application}
PPVWindow = ^TPVWindow;
TPVWindow = object(TWindow)
FWin:PFontWindow; {child window displaying typeface sample}
FBox:PListBox; {List box of available type faces}
TheIcon:HIcon;
Bn1,Bn2,Bn3,Bn4,Bn5 :PODButton;
Dlg1 : PPVDlg1; {Select font size dialog}
St1,St2,St3,St4:PStatic;
TextString:Array[0..80] of Char; {to display in FWin}
FontSelection:Integer; {Index into Faces collection}
FontSize:Integer; {Current font size desired for FWin}
PFontSize:Integer; {Current font size for printed text}
LogPixX,LogPixY:Integer; {LogPixelsX & Y for current Printer}
constructor Init(AParent:PWindowsObject;ATitle:PChar);
destructor Done;virtual;
procedure SetupWindow;virtual;
procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
procedure LoadFBox;
procedure WMDrawItem(var Msg:TMessage);virtual wm_First + wm_DrawItem;
procedure WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
procedure WMSetFocus(var Msg:TMessage);virtual wm_First+wm_SetFocus;
procedure IDBut1(var Msg:TMessage);virtual id_First+id_But1; {About}
procedure IDBut2(var Msg:TMessage);virtual id_First+id_But2; {Size}
procedure IDBut3(var Msg:TMessage);virtual id_First+id_But3; {String}
procedure IDBut4(var Msg:TMessage);virtual id_First+id_But4; {Text Metrics}
procedure IDBut5(var Msg:TMessage);virtual id_First+id_But5; {Exit}
procedure IDLB2(var Msg:TMessage);virtual id_First+id_lb2;
procedure EnumerateFaces;virtual;
procedure EnumerateSizes;virtual;
function GetFontSelection:Integer;virtual;
function GetFontSize:Integer;virtual;
function GetTextString:PChar;virtual;
function GetLogPixX:Integer;virtual;
function GetLogPixY:Integer;virtual;
procedure SetFontSize(NewfontSize:Integer);virtual;
procedure SetPFontSize(NewfontSize:Integer);virtual;
procedure UMFilePrint(var Msg:TMessage);virtual wm_User+um_FilePrint;
procedure WMSysCommand(var Msg:TMessage);virtual wm_First+wm_SysCommand;
end;
{********************************************************************}
{G L O B A L V A R I A B L E S }
{********************************************************************}
var
Faces:PFontCollection; {collection of PFontItem for call-back func}
Sizes:PCollection; {collection of stacks for call-back func}
{********************************************************************}
{M E T H O D S }
{********************************************************************}
procedure TPVApplication.InitMainWindow;
begin
MainWindow := New(PPVWindow,Init(nil,'Font Preview'));
end;
{********************************************************************}
{Init}
constructor TPVWindow.Init(AParent:PWindowsObject;ATitle:PChar);
begin
TWindow.Init(AParent,ATitle);
Attr.Menu := 0; {LoadMenu(HInstance,'PV_Menu');}
Attr.X := 20; Attr.Y := 25; Attr.W := 595; Attr.H := 260;
Bn1 := New(PODButton,Init(@Self,id_But1,'Font Size',0,0,50,50,False,'PV_Bn1'));
Bn2 := New(PODButton,Init(@Self,id_But2,'Font Size',50,0,50,50,False,'PV_Bn2'));
Bn3 := New(PODButton,Init(@Self,id_But3,'String',100,0,100,50,False,'PV_Bn3'));
Bn4 := New(PODButton,Init(@Self,id_But4,'String',200,0,50,50,False,'PV_Bn4'));
Bn5 := New(PODButton,Init(@Self,id_But5,'Exit',250,0,50,50,False,'PV_Bn5'));
St1 := New(PStatic,Init(@Self,id_St1,'',315,5,240,18,75));
St2 := New(PStatic,Init(@Self,id_St2,'',315,26,240,18,75));
St3 := New(PStatic,Init(@Self,id_ST3,'',310,3,250,44,75));
St4 := New(PStatic,Init(@Self,id_St4,'',5,55,140,18,75));
St2^.Attr.Style := St2^.Attr.Style or ss_LeftNoWordWrap;
St3^.Attr.Style := St3^.Attr.Style or ss_BlackFrame;
St4^.Attr.Style := St4^.Attr.Style or ss_Left;
LogPixY := 1;
FontSelection := 0;
FontSize := 48;
PFontsize := 14;
StrCopy(TextString,'');
Faces := New(PFontCollection,Init(100,100));
Faces^.Duplicates := False;
Sizes := New(PCollection,Init(10,10));
EnumerateFaces;
EnumerateSizes;
FWin := New(PFontWindow,Init(@Self,ATitle));
with FWin^.Attr do
Style := Style or ws_Child or ws_HScroll or ws_VScroll or ws_Border ;
FBox := New(PListBox,Init(@Self,id_lb2,0,0,0,0));
with FBox^.Attr do
begin
Style := Style and not lbs_Sort ;
end;
end;
{SetupWindow}
procedure TPVWindow.SetupWindow;
var
SysMenu:hMenu;
begin
TWindow.SetupWindow;
SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'PV_Icon'));
Sysmenu := GetSystemMenu(hWindow,false);
AppendMenu(SysMenu,MF_Separator,0,nil);
AppendMenu(SysMenu,0,idm_RunCP,'Run Control Panel');
AppendMenu(Sysmenu,0,idm_About,'About...');
LoadFBox;
end;
{Paint}
procedure TPVWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
ThePen:HPen;
TheBrush :HBrush;
OldBrush :HBrush;
OldPen:HPen;
begin
TheBrush := GetStockObject(LtGray_Brush);
ThePen := CreatePen(ps_Solid,1,$00000000);
OldPen := SelectObject(PaintDC,ThePen);
OldBrush := SelectObject(PaintDC,TheBrush);
Rectangle(PaintDC,0,0,1024,50);
SelectObject(PaintDC,OldBrush);
SelectObject(PaintDC,OldPen);
DeleteObject(ThePen);
end;
{Route the Ownerdraw msgs to correct object}
procedure TPVWindow.WMDrawItem(var Msg:TMessage);
var
PDIS : ^TDrawItemStruct;
begin
PDIS := Pointer(Msg.lParam);
case PDIS^.CtlType of
odt_Button:
case PDIS^.CtlID of
id_But1 :Bn1^.DrawItem(Msg);
id_But2 :Bn2^.DrawItem(Msg);
id_But3 :Bn3^.DrawItem(Msg);
id_But4 :Bn4^.DrawItem(Msg);
id_But5 :Bn5^.DrawItem(Msg);
end;
end;
end;
{Done}
destructor TPVWindow.Done;
begin
Dispose(Sizes,Done);
TWindow.Done;
end;
{WMSize}
procedure TPVWindow.WMSize(var Msg:TMessage);
begin
SetWindowPos(FBox^.HWindow,0,-1,75,(Msg.LParamLo div 3)+1,
((Msg.LParamHi-70) ),swp_NoZOrder);
SetWindowPos(FWin^.HWindow,0,(Msg.LParamLo div 3)-1,49,
(Msg.LParamLo * 2 div 3)+1,(Msg.LParamHi-48),swp_NoZOrder);
end;
{WMSetFocus}
procedure TPVWindow.WMSetFocus(var Msg:TMessage);
begin
SetFocus(FBox^.HWindow);
end;
procedure TPVWindow.IDBut1(var Msg:TMessage);
var
Dlg : PDialog;
begin
Dlg :=New(PPVDlg3,Init(@Self,'PV_Dlg3'));
Application^.ExecDialog(Dlg);
end;
{IDBut2} {run font size dialog box}
procedure TPVWindow.IDBut2(var Msg:TMessage);
begin
Dlg1 := new(PPVDlg1,Init(@Self,'PV_Dlg1'));
Application^.ExecDialog(Dlg1);
if (Dlg1^.FontSize) <> 0 then
InvalidateRect(Fwin^.HWindow,nil,True);
end;
{IDBut3} {run sample string dialog box}
procedure TPVWindow.IDBut3(var Msg:TMessage);
var
TotChars:Integer;
begin
If Application^.ExecDialog(New(PInputdialog,Init(@Self,'Font String',
'Enter text:',TextString,SizeOf(TextString)))) = 1 then
else StrCopy(TextString,'');
InvalidateRect(FWin^.HWindow,nil,True);
end;
{IdBut4} {GetTextMetrics}
procedure TPVWindow.IDBut4(var Msg:TMessage);
var
Dlg : PPVDlg2;
begin
Dlg :=New(PPVDlg2,Init(@Self,'PV_Dlg2'));
Dlg^.DCType := 'S';
Application^.ExecDialog(Dlg);
Dlg :=New(PPVDlg2,Init(@Self,'PV_Dlg2'));
Dlg^.DCType := 'P';
Application^.ExecDialog(Dlg);
end;
{IdBut5} {exit}
procedure TPVWindow.IDBut5(var Msg:TMessage);
begin
SendMessage(HWindow,wm_Close,0,0);
end;
procedure TPVWindow.LoadFBox;
var
Indx : Integer;
Font : PFontItem;
Buf1 :Array[0..20] of Char;
Buf2 :Array[0..5] of Char;
begin
Str(Faces^.Getcount,Buf2);
StrECopy(StrECopy(StrECopy(Buf1,'*'),Buf2),' Type Faces*');
St4^.SetText(Buf1);
for indx := 0 to (Faces^.GetCount -1) do
begin
Font := Faces^.At(indx);
FBox^.InsertString(Font^.LogFont.lfFaceName,-1);
end;
end;
procedure TPVWindow.IDLB2(var Msg:TMessage);
var
szBuffer:Array[0..80] of Char;
indx:Integer;
begin
case Msg.lParamHi of
lbn_DblClk, lbn_SelChange:
begin
indx := FBox^.GetSelIndex;
FontSelection := Indx;
InvalidateRect(FWin^.HWindow,nil,True);
Exit;
end;
end;
end;
function EnumerateFace(var LogFont: TLogFont; TextMetric: PTextMetric;
FontType: Integer; Data: PChar): Integer; export;
function DupF(Item:PFontItem):Boolean;far;
begin
DupF := (StrIComp(Item^.LogFont.lfFaceName, LogFont.lfFacename)= 0);
end;
var
OldFont: HFont;
Result:PFontItem;
begin
Result := Faces^.FirstThat(@DupF);
if Result = nil then Faces^.Insert(New(PFontItem,Init(LogFont,FontType)));
EnumerateFace := 1;
end;
function EnumerateSize(var LogFont: TLogFont; TextMetric: PTextMetric;
FontType: Integer; Data: PChar): Integer; export;
function DupS(Item:PStackInt):Boolean;far;
begin
DupS := (Item^.StackInt = LogFont.lfHeight);
end;
var
FHeight:Array[0..6] of Char;
PStk :PStack;
Result :PStackInt;
begin
PStk :=Sizes^.At(Sizes^.Count-1);
Result := PStk^.FirstThat(@DupS);
if Result = nil then PStk^.Push(New(PStackInt,Init(LogFont.lfHeight))) ;
EnumerateSize := 1;
end;
{ Collect all of faces of current system printer }
procedure TPVWindow.EnumerateFaces;
var
EnumProc: TFarProc;
ThePrinter:pPVPrinter;
begin
ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
ThePrinter^.GetPrinterParms;
ThePrinter^.DCCreated;
EnumProc := MakeProcInstance(@EnumerateFace, HInstance);
EnumFonts(ThePrinter^.hPrintDC, nil, EnumProc,nil);
LogPixY := GetDeviceCaps(ThePrinter^.hPrintDC,LogPixelsY);
LogPixX := GetDeviceCaps(ThePrinter^.hPrintDC,LogPixelsX);
ThePrinter^.DeleteContext;
Dispose(ThePrinter,Done);
end;
{ Collect all of sizes for each face of current system printer }
procedure TPVWindow.EnumerateSizes;
var
EnumProc: TFarProc;
ThePrinter:pPVPrinter;
FontItem :PFontItem;
Indx : Integer;
begin
ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
ThePrinter^.GetPrinterParms;
ThePrinter^.DCCreated;
EnumProc := MakeProcInstance(@EnumerateSize, HInstance);
for Indx := 0 to Faces^.Count -1 do
begin
FontItem := Faces^.At(Indx);
Sizes^.Insert(New(PStack,Init(10,10)));
EnumFonts(ThePrinter^.hPrintDC, FontItem^.LogFont.lfFaceName,
EnumProc,nil);
end;
ThePrinter^.DeleteContext;
Dispose(ThePrinter,Done);
end;
function TPVWindow.GetFontSelection:Integer;
begin
GetFontSelection := FontSelection;
end;
function TPVWindow.GetFontSize:Integer;
begin
GetFontSize := FontSize;
end;
function TPVWindow.GetTextString:PChar;
begin
GetTextString := @TextString;
end;
procedure TPVWindow.SetFontSize(NewFontSize:Integer);
begin
FontSize := NewFontSize;
end;
procedure TPVWindow.SetPFontSize(NewFontSize:Integer);
begin
PFontSize := NewFontSize;
end;
function TPVWindow.GetLogPixX:Integer;
begin
GetLogPixX := LogPixX;
end;
function TPVWindow.GetLogPixY:Integer;
begin
GetLogPixY := LogPixY;
end;
procedure TPVWindow.UMFilePrint(var Msg:TMessage);
var
aPtr : pPVPrinter;
indx : Integer;
FI : PFontItem;
OldFont,NewFont:hFont;
szSize:Array[0..7] of Char;
LogFont:TLogFont;
TM:TTextMetric;
Buf1:Array[0..60] of Char;
begin
aPtr := New(pPVPrinter,Init(hInstance,@Self));
indx := 0;
if aPtr^.Start('PreView',hWindow) then
begin
aPtr^.SetMarginB(LogPixY div 3);
aPtr^.SetMarginL(LogPixX+LogPixX); {Indent 2 inches}
aptr^.ResetPos;
StrECopy(StrECopy(Buf1,'Printer Font Samples: '),aPtr^.DeviceName);
aPtr^.printLine(Buf1);
aPtr^.SetMarginL(LogPixX); {Set margin = 1 inch}
aPtr^.NewLine;
for indx := 0 to (Faces^.GetCount-1) do
begin
FI := Faces^.At(Indx);
FI^.LogFont.lfHeight := PFontsize * LogPixY div 72;
FI^.LogFont.lfWidth := 0;
FI^.LogFont.lfWeight := fw_Normal;
FI^.LogFont.lfQuality := Proof_Quality;
NewFont := CreateFontIndirect(FI^.LogFont);
OldFont := aPtr^.SetFont(NewFont);
getTextMetrics(aPtr^.hPrintDC,TM);
Str(TM.tmHeight * 72 / LogPixY:3:0,szSize);
StrCat(StrCat(StrCopy(Buf1,FI^.LogFont.lfFaceName),szSize),
' ABCDEFG!@#$%^&* abcdefg()_+\<>? 123456789');
aPtr^.printLine(Buf1);
OldFont := aPtr^.SetFont(OldFont);
DeleteObject(NewFont);
end;
aPtr^.Finish;
Dispose(aPtr,Done);
end;
end;
procedure TPvWindow.WMSysCommand(var Msg:TMessage);
begin
case Msg.Wparam of
idm_About:Application^.ExecDialog(New(PDialog,Init(@Self,'PV_About')));
idm_RunCP:begin
WinExec('Control',1);
EnumerateFaces;
EnumerateSizes;
end;
else
DefWndProc(Msg);
end;
end;
{***********************************************************************}
{ Initialize object and collect font information }
constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);
begin
TWindow.Init(AParent, ATitle);
Attr.Style := Attr.Style or ws_VScroll or ws_HScroll or ws_Border;
FontsHeight := 0;
Scroller := New(PScroller, Init(@Self, 12, 12,0,0));
end;
{ Draw font name in Window & update static text}
procedure TFontWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
I: Integer;
VPosition: Integer;
FontItem :PFontItem;
FontSel:Integer;
AFont:HFont;
OldFont:HFont;
Extent:LongRec;
Text:Array[0..80] of Char;
Buf:Array[0..80] of Char;
FH:Real;
szFH:Array[0..5] of Char;
LPY:Integer;
FontMetrics:TTextMetric;
begin {build text display}
LPY := GetDeviceCaps(PaintDC,LogPixelsY);
FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
FontsHeight := PPVWindow(Parent)^.GetFontSize * LPY div 72;
FontItem^.LogFont.lfHeight := FontsHeight;
FontItem^.LogFont.lfWidth := 0;
FontItem^.LogFont.lfWeight := 0;
FontItem^.LogFont.lfQuality := Proof_Quality;
VPosition := 5;
if StrComp(PPVWindow(Parent)^.GetTextString,'') = 0
then StrCopy(Text,FontItem^.LogFont.lfFaceName)
else StrCopy(Text,PPVWindow(Parent)^.GetTextString);
AFont := CreateFontIndirect(FontItem^.LogFont);
OldFont := SelectObject(PaintDC, AFont);
GetTextMetrics(PaintDC,FontMetrics);
LongInt(Extent) := GetTextExtent(PaintDC,Text,
StrLen(Text));
Scroller^.SetRange(Extent.lo div 12, Extent.Hi div 12);
TextOut(PaintDC, 10,VPosition, Text,
StrLen(Text));
{Set static text}
StrCopy(Buf,'Face: ');
PPVWindow(Parent)^.St1^.SetText(StrCat(Buf,FontItem^.LogFont.lfFaceName));
FH :=(FontMetrics.tmHeight)*72 / LPY;
Str(FH:5:1,szFH);
StrECopy(StrECopy(Buf,'Actual :'),szFH);
if FontItem^.FontType and Raster_FontType = 0 then
StrCat(Buf,' Type:Vector,') else StrCat(Buf,' Type:Raster,');
if FontItem^.FontType and Device_FontType = 0 then
StrCat(Buf,'GDI') else StrCat(Buf,'Device');
PPVWindow(Parent)^.St2^.SetText(Buf);
SelectObject(PaintDC,OldFont);
DeleteObject(AFont);
end;
procedure TFontWindow.Destroy;
begin
TWindow.Destroy;
end;
procedure TFontWindow.WMSize(var Msg: TMessage);
begin
TWindow.WMSize(Msg);
end;
{***********************************************************************}
constructor TFontItem.Init(NewItem:TLogFont;NewType:Integer);
begin
LogFont := NewItem;
FontType := NewType;
end;
destructor TFontItem.Done;
begin
end;
{***********************************************************************}
function TFontCollection.KeyOf(Item:Pointer):Pointer;
var
Ptr :PChar;
begin
Ptr := PFontItem(Item)^.LogFont.lfFaceName;
KeyOf := Ptr;
end;
function TFontCollection.Compare(Key1,Key2:Pointer):Integer;
begin
Compare := StrIComp(PChar(Key1),PChar(Key2));
end;
function TFontCollection.GetCount:Integer;
begin
GetCount := Count;
end;
{***********************************************************************}
procedure TPVDlg1.IDLb1(var Msg:TMessage);
var
Idx : Integer;
Buf:Array[0..5] of Char;
Ptr : PChar;
ErrCode:Integer;
begin
case Msg.lParamHi of
lbn_SelChange,lbn_DblClk:
begin
Ptr := Buf;
Idx := SendDlgItemMsg(id_Lb1,lb_GetCurSel,0,0);
SendDlgItemMsg(id_Lb1,lb_GetText,word(Idx),LongInt(Ptr));
val(Ptr,FontSize,ErrCode);
PPVWindow(Parent)^.SetFontSize(FontSize);
EndDlg(Idx);
Exit;
end;
end;
end;
procedure TPVDlg1.WMInitDialog(var Msg:TMessage);
var
pTextItem:PChar;
Buf:Array[0..5] of Char;
Indx:Integer;
DSN,ErrCode :Integer;
EnumProc:TFarProc;
TheDC:HDc;
FontItem:PFontItem;
Item:PStackInt;
Flag:PChar;
ThePrinter:pPVPrinter;
LPY : Integer;
PStk :PStack;
Height:Integer;
Indx2:Integer;
Res,Res2:Integer;
begin
TDialog.WMInitDialog(Msg);
FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
PStk := Sizes^.At(PPVWindow(Parent)^.GetFontSelection);
Indx2 := 0;
Indx := 12;
pTextItem := Buf;
Res := FontItem^.FontType and Raster_FontType; {0 = vector font}
Res2 := FontItem^.FontType and Device_FontType; {0 = GDI font}
if Res = 0 then
begin
Str(Indx:3,Buf);
while Indx < 200 do
begin
SendDlgItemMsg(id_Lb1,lb_AddString,word(0),LongInt(pTextItem));
Indx := Indx + 12;
Str(Indx:3,Buf);
end;
end
else
for Indx2 := 0 to PStk^.Count-1 do
begin
Item := PStk^.At(Indx2);
Height := Item^.StackInt;
Str(Height * 72 div PPVWindow(Parent)^.GetLogPixY:3,Buf);
SendDlgItemMsg(id_Lb1,lb_AddString,word(0),LongInt(pTextItem));
end;
end;
{***********************************************************************}
procedure TPVDlg2.WMInitDialog(var Msg:TMessage);
const
FontFamily : Array[0..5,0..11] of Char = ('Don''t Care', ' Roman',
' Swiss',' Modern', ' Script', 'Decorative');
var
FontItem:PFontItem;
TextItem:PChar;
Buf:Array[0..3] of Char;
Buf60:Array[0..60] of Char;
FontMetrics:TTextMetric;
aPtr:pPVPrinter;
OldFont,NewFont:hFont;
LogFont:TLogFont;
DeviceName:Array[0..30] of Char;
ScreenDC:hDC;
begin
FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
if DCType = 'P' then
begin
aPtr := New(pPVPrinter,Init(hInstance,@Self));
aPtr^.GetPrinterParms;
aPtr^.DCCreated;
StrCopy(DeviceName,aPtr^.DeviceName);
FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize *
GetDeviceCaps(aPtr^.hPrintDC,LogPixelsY) div 72;
FontItem^.LogFont.lfQuality := Proof_Quality;
FontItem^.LogFont.lfWeight := fw_Normal;
NewFont := CreateFontIndirect(FontItem^.LogFont);
OldFont := aPtr^.SetFont(NewFont);
GetTextMetrics(aPtr^.hPrintDC,FontMetrics);
aPtr^.SetFont(OldFont);
DeleteObject(NewFont);
aPtr^.DeleteContext;
Dispose(aPtr,Done);
end
else
begin
StrCopy(DeviceName,'Screen Display');
ScreenDC :=GetDC(PPVWindow(Parent)^.HWindow);
FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize *
GetDeviceCaps(ScreenDC,LogPixelsY) div 72;
FontItem^.LogFont.lfQuality := Proof_Quality;
FontItem^.LogFont.lfWeight := fw_Normal;
NewFont := CreateFontIndirect(FontItem^.LogFont);
OldFont := SelectObject(ScreenDC,Newfont);
GetTextMetrics(ScreenDC,FontMetrics);
SelectObject(ScreenDC,OldFont);
DeleteObject(NewFont);
ReleaseDC(PPVWindow(Parent)^.HWindow,ScreenDC);
end;
TDialog.WMInitDialog(Msg);
StrECopy(StrECopy(StrECopy(Buf60,FontItem^.LogFont.lfFaceName),' - '),DeviceName);
SetDlgItemText(HWindow,601,Buf60);
Str(FontMetrics.tmHeight:3,Buf); SetDlgItemText(HWindow,612,Buf);
Str(FontMetrics.tmAscent:3,Buf); SetDlgItemText(HWindow,613,Buf);
Str(FontMetrics.tmDescent:3,Buf); SetDlgItemText(HWindow,614,Buf);
Str(FontMetrics.tmInternalLeading:3,Buf); SetDlgItemText(HWindow,615,Buf);
Str(FontMetrics.tmExternalLeading:3,Buf); SetDlgItemText(HWindow,616,Buf);
Str(FontMetrics.tmAveCharWidth:3,Buf); SetDlgItemText(HWindow,617,Buf);
Str(FontMetrics.tmMaxCharWidth:3,Buf); SetDlgItemText(HWindow,618,Buf);
Str(FontMetrics.tmWeight:3,Buf); SetDlgItemText(HWindow,619,Buf);
Str(FontMetrics.tmItalic:3,Buf); SetDlgItemText(HWindow,620,Buf);
Str(FontMetrics.tmUnderlined:3,Buf); SetDlgItemText(HWindow,621,Buf);
Str(FontMetrics.tmStruckOut:3,Buf); SetDlgItemText(HWindow,632,Buf);
Str(FontMetrics.tmFirstChar:3,Buf); SetDlgItemText(HWindow,633,Buf);
Str(FontMetrics.tmLastChar:3,Buf); SetDlgItemText(HWindow,634,Buf);
Str(FontMetrics.tmDefaultChar:3,Buf); SetDlgItemText(HWindow,635,Buf);
if FontMetrics.tmPitchandFamily and 1 > 0 then SetDlgItemText(HWindow,636,'Variable')
else SetDlgItemText(HWindow,636,'Fixed');
SetDlgItemText(HWindow,637,FontFamily[FontMetrics.tmPitchAndFamily shr 4] );
if FontMetrics.tmCharSet = ANSI_CharSet then SetDlgItemText(HWindow,638,'Ansi')
else if FontMetrics.tmCharSet = OEM_CharSet then SetDlgItemText(HWindow,638,'OEM')
else if FontMetrics.tmCharSet = Symbol_CharSet then SetDlgItemText(HWindow,638,'Symbol')
else if FontMetrics.tmCharSet = ShiftJis_CharSet then SetDlgItemText(HWindow,638,'ShiftJis')
else SetDlgItemText(HWindow,638,' ');
Str(FontMetrics.tmOverHang:3,Buf); SetDlgItemText(HWindow,639,Buf);
Str(FontMetrics.tmDigitizedAspectX:3,Buf); SetDlgItemText(HWindow,640,Buf);
Str(FontMetrics.tmDigitizedAspectY:3,Buf); SetDlgItemText(HWindow,641,Buf);
end;
{*********************************************************************}
procedure TPVDlg3.WMInitDialog(var Msg:TMessage);
var
ThePrinter:pPVPrinter;
DeviceName:Array[0..40] of Char;
begin
TDialog.WMInitDialog(Msg);
ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
ThePrinter^.GetPrinterParms;
ThePrinter^.DCCreated;
StrCopy(DeviceName,ThePrinter^.deviceName);
ThePrinter^.DeleteContext;
Dispose(ThePrinter,Done);
SetDlgItemText(HWindow,503,DeviceName);
end;
procedure TPVDlg3.IDSetup(var Msg:TMessage);
var
ThePrinter:pPVPrinter;
begin
ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
ThePrinter^.prnDeviceMode(hWindow);
dispose(ThePrinter,Done);
pPVWindow(Parent)^.EnumerateFaces;
pPVWindow(Parent)^.EnumerateSizes;
end;
procedure TPVDlg3.IDOKPrt(var Msg:TMessage);
begin
EndDlg(1);
SendMessage(PPVWindow(Parent)^.HWindow,wm_User+um_FilePrint,Msg.wParam,Msg.LParam);
end;
procedure TPVDlg3.IDEC1(var Msg:TMessage);
var
Idx : Integer;
Buf:Array[0..5] of Char;
Ptr : PChar;
ErrCode:Integer;
FontSize:Integer;
return:Integer;
begin
case Msg.lParamHi of
en_Change:
begin
Ptr := Buf;
Idx := 5;
Return := SendDlgItemMsg(id_Ec1,wm_GetText,word(Idx),LongInt(Ptr));
val(Ptr,FontSize,ErrCode);
PPVWindow(Parent)^.SetPFontSize(FontSize);
Exit;
end;
end;
end;
{*********************************************************************}
function TPVPrinter.SetFont(NewFont:hFont):hFont;
var
MM:Integer;
LogFont:TLogFont;
begin
SetFont := SelectObject(hPrintDC,NewFont);
getTextMetrics(hPrintDC,Metrics);
MM := GetMapMode(hPrintDC);
GetObject(NewFont,sizeof(LogFont),@LogFont);
end;
function TPVPrinter.Start(dName:pChar;hw:HWnd):Boolean;
begin
MarginL := 0;
MarginT := 0;
MarginR := 0;
MarginB := 0;
Start := tPrinter.Start(dName,hw); {ancestor call}
end;
procedure TPVPrinter.SetMarginL(NewMargin:Integer);
begin
MarginL := NewMargin;
end;
procedure TPVPrinter.SetMarginT(NewMargin:Integer);
begin
MarginT := NewMargin;
end;
procedure TPVPrinter.SetMarginR(NewMargin:Integer);
begin
MarginR := NewMargin;
end;
procedure TPVPrinter.SetMarginB(NewMargin:Integer);
begin
MarginB := NewMargin;
end;
function TPVPrinter.NewLine:Boolean;
Begin
posX := MarginL;
posY := posY + height;
checkNewPage;
end;
function TPVPrinter.ResetPos:Boolean;
Begin
posX := MarginL;
posY := MarginT;
end;
function TPVPrinter.CheckNewPage:Boolean;
begin
if (posY + MarginB > maxY ) then newPage;
end;
function TPVPrinter.Print(aStr:pchar):Boolean;
var
Extent:Integer;
begin
Extent := lineWidth(aStr);
if ((PosX + Extent + MarginR) > maxX) then
newLine;
if printString(aStr) then
begin
PosX := PosX + Extent;
Print := True;
end
else
Print := False;
end;
function TPVPrinter.prnDeviceMode(Wnd:HWnd):Integer;
var
dHandle: tHandle; {handle of the load library for the current printer}
drvName: pChar; {name of the driver used to get dHandle}
pAddr: tFarProc; {address of the function in the DLL we want to EXEC}
Begin
if getPrinterParms then begin {retrieve printer info from windows}
drvName := driver;
strCat(drvName,'.drv'); {make a file name out of the driver}
dHandle := LoadLibrary(drvName); {load the DLL for the printer}
pAddr := getProcAddress(dHandle,'ExtDeviceMode');
if (pAddr <> nil) then begin
tGetExtDevMode(pAddr)(wnd,dHandle,dMode,drvName,prnPort,dMode,nil,
dm_prompt OR dm_Update);
end else begin
pAddr := GetProcAddress(dHandle,'DEVICEMODE');
if (pAddr <> nil) then begin
tGetDevMode(pAddr)(wnd,dHandle,drvName,prnPort);
End;
End;
FreeLibrary(dHandle); {the library is freed when we are done with it}
End;
end;
{*********************************************************************}
{*** M A I N L I N E }
{*********************************************************************}
var
PVApp : TPVApplication;
begin
PVApp.Init('Font Preview');
PVApp.Run;
PVApp.Done;
end.